home *** CD-ROM | disk | FTP | other *** search
/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / POPFile / Mutex.pm < prev    next >
Encoding:
Perl POD Document  |  2004-12-06  |  2.9 KB  |  104 lines
  1. package POPFile::Mutex;
  2.  
  3. #----------------------------------------------------------------------------
  4. #
  5. # This is a mutex object that uses mkdir() to provide exclusive access
  6. # to a region on a per thread or per process basis.
  7. #
  8. # Copyright (c) 2001-2004 John Graham-Cumming
  9. #
  10. #   This file is part of POPFile
  11. #
  12. #   POPFile is free software; you can redistribute it and/or modify
  13. #   it under the terms of the GNU General Public License as published by
  14. #   the Free Software Foundation; either version 2 of the License, or
  15. #   (at your option) any later version.
  16. #
  17. #   POPFile is distributed in the hope that it will be useful,
  18. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. #   GNU General Public License for more details.
  21. #
  22. #   You should have received a copy of the GNU General Public License
  23. #   along with POPFile; if not, write to the Free Software
  24. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  25. #
  26. #----------------------------------------------------------------------------
  27.  
  28. use strict;
  29.  
  30. #----------------------------------------------------------------------------
  31. # new
  32. #
  33. #   Create a new Mutex object (which may refer to a file referred to by
  34. #   other mutexes) with a specific name generated from the name passed
  35. #   in.
  36. #
  37. #----------------------------------------------------------------------------
  38. sub new
  39. {
  40.     my ( $type, $name ) = @_;
  41.     my $self;
  42.  
  43.     $self->{name__} = "popfile_mutex_${name}.mtx";
  44.     release( $self );
  45.  
  46.     return bless $self, $type;
  47. }
  48.  
  49. #----------------------------------------------------------------------------
  50. #
  51. # acquire
  52. #
  53. #   Returns 1 if it manages to grab the mutex (and will block if necessary)
  54. #   and 0 if it fails.
  55. #
  56. #----------------------------------------------------------------------------
  57. sub acquire
  58. {
  59.     my ( $self,             # Reference to this object
  60.          $timeout ) = @_;   # Timeout in seconds to wait (undef = infinite)
  61.  
  62.     # If acquire() has been called without a matching release() then
  63.     # fail at once
  64.  
  65.     if ( defined( $self->{locked__} ) ) {
  66.         return 0;
  67.     }
  68.  
  69.     # Wait a very long time if no timeout is specified
  70.  
  71.     $timeout = 0xFFFFFFFF if ( !defined( $timeout ) );
  72.     my $now = time;
  73.  
  74.     # Try to create a directory during the timeout period
  75.  
  76.     do {
  77.         if ( mkdir( $self->{name__}, 0755 ) ) { # Create a directory
  78.             $self->{locked__} = 1;
  79.             return 1;
  80.         }
  81.         select( undef, undef, undef, 0.01 );
  82.     } while ( time < ( $now + $timeout ) );
  83.  
  84.     # Timed out so return 0
  85.     return 0;
  86. }
  87.  
  88. #----------------------------------------------------------------------------
  89. #
  90. # release
  91. #
  92. #   Release the lock if we acquired it with a call to acquire()
  93. #
  94. #----------------------------------------------------------------------------
  95. sub release
  96. {
  97.     my ( $self ) = @_;
  98.  
  99.     rmdir( $self->{name__} ); # Delete the Mutex directory
  100.     $self->{locked__} = undef;
  101. }
  102.  
  103. 1;
  104.